home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / language / ici / ici.cpi / forall.c < prev    next >
C/C++ Source or Header  |  1994-10-27  |  4KB  |  208 lines
  1. #include "exec.h"
  2. #include "struct.h"
  3. #include "set.h"
  4. #include "forall.h"
  5. #include "str.h"
  6. #include "buf.h"
  7.  
  8. STATIC long
  9. mark_forall(fa)
  10. forall_t    *fa;
  11. {
  12.     register int    i;
  13.     long        mem;
  14.  
  15.     objof(fa)->o_flags |= O_MARK;
  16.     mem = sizeof(forall_t);
  17.     for (i = 0; i < nels(fa->fa_objs); ++i)
  18.     {
  19.     if (fa->fa_objs[i] != NULL)
  20.         mem += mark(fa->fa_objs[i]);
  21.     }
  22.     return mem;
  23. }
  24.  
  25. /*
  26.  * va vk ka kk aggr code    => (os)
  27.  *                => forall (xs)
  28.  */
  29. int
  30. op_forall()
  31. {
  32.     register forall_t    *fa;
  33.  
  34.     if (o_top[-2] == objof(&o_null))
  35.     {
  36.     o_top -= 6;
  37.     --x_top;
  38.     return 0;
  39.     }
  40.     if ((fa = talloc(forall_t)) == NULL)
  41.     return 1;
  42.     objof(fa)->o_type = &forall_type;
  43.     objof(fa)->o_tcode = TC_FORALL;
  44.     objof(fa)->o_flags = 0;
  45.     objof(fa)->o_nrefs = 0;
  46.     rego(fa);
  47.     fa->fa_index = -1;
  48.     fa->fa_code = *--o_top;
  49.     fa->fa_aggr = *--o_top;
  50.     fa->fa_kkey = *--o_top;
  51.     fa->fa_kaggr = *--o_top;
  52.     fa->fa_vkey = *--o_top;
  53.     fa->fa_vaggr = *--o_top;
  54.     x_top[-1] = objof(fa);
  55.     return 0;
  56. }
  57.  
  58. /*
  59.  * forall => forall pc (xs)
  60.  *  OR
  61.  * forall => (xs)
  62.  */
  63. int
  64. exec_forall()
  65. {
  66.     register forall_t    *fa;
  67.     char        n[30];
  68.  
  69.     fa = forallof(x_top[-1]);
  70.     switch (fa->fa_aggr->o_tcode)
  71.     {
  72.     case TC_STRUCT:
  73.     {
  74.         register struct_t    *s;
  75.         register slot_t    *sl;
  76.  
  77.         s = structof(fa->fa_aggr);
  78.         while (++fa->fa_index < s->s_nslots)
  79.         {
  80.         if ((sl = &s->s_slots[fa->fa_index])->sl_key == NULL)
  81.             continue;
  82.         if (fa->fa_vaggr != objof(&o_null))
  83.         {
  84.             if (assign(fa->fa_vaggr, fa->fa_vkey, sl->sl_value))
  85.             return 1;
  86.         }
  87.         if (fa->fa_kaggr != objof(&o_null))
  88.         {
  89.             if (assign(fa->fa_kaggr, fa->fa_kkey, sl->sl_key))
  90.             return 1;
  91.         }
  92.         goto next;
  93.         }
  94.     }
  95.     goto fin;
  96.  
  97.     case TC_SET:
  98.     {
  99.         register set_t    *s;
  100.         register object_t    **sl;
  101.  
  102.         s = setof(fa->fa_aggr);
  103.         while (++fa->fa_index < s->s_nslots)
  104.         {
  105.         if (*(sl = &s->s_slots[fa->fa_index]) == NULL)
  106.             continue;
  107.         if (fa->fa_kaggr == objof(&o_null))
  108.         {
  109.             if (fa->fa_vaggr != objof(&o_null))
  110.             {
  111.             if (assign(fa->fa_vaggr, fa->fa_vkey, *sl))
  112.                 return 1;
  113.             }
  114.         }
  115.         else
  116.         {
  117.             if (fa->fa_vaggr != objof(&o_null))
  118.             {
  119.             if (assign(fa->fa_vaggr, fa->fa_vkey, objof(o_one)))
  120.                 return 1;
  121.             }
  122.             if (assign(fa->fa_kaggr, fa->fa_kkey, *sl))
  123.             return 1;
  124.         }
  125.         goto next;
  126.         }
  127.     }
  128.     goto fin;
  129.     
  130.     case TC_ARRAY:
  131.     {
  132.         register array_t    *a;
  133.         register int_t    *i;
  134.  
  135.         a = arrayof(fa->fa_aggr);
  136.         if (++fa->fa_index >= a->a_top - a->a_base)
  137.         goto fin;
  138.         if (fa->fa_vaggr != objof(&o_null))
  139.         {
  140.         if (assign(fa->fa_vaggr, fa->fa_vkey, a->a_base[fa->fa_index]))
  141.             return 1;
  142.         }
  143.         if (fa->fa_kaggr != objof(&o_null))
  144.         {
  145.         if ((i = new_int((long)fa->fa_index)) == NULL)
  146.             return 1;
  147.         if (assign(fa->fa_kaggr, fa->fa_kkey, i))
  148.             return 1;
  149.         loose(i);
  150.         }
  151.     }
  152.     goto next;
  153.  
  154.     case TC_STRING:
  155.     {
  156.         register string_t    *s;
  157.         register int_t    *i;
  158.  
  159.         s = stringof(fa->fa_aggr);
  160.         if (++fa->fa_index >= s->s_nchars)
  161.         goto fin;
  162.         if (fa->fa_vaggr != objof(&o_null))
  163.         {
  164.         if ((s = new_name(&s->s_chars[fa->fa_index], 1)) == NULL)
  165.             return 1;
  166.         if (assign(fa->fa_vaggr, fa->fa_vkey, s))
  167.             return 1;
  168.         loose(s);
  169.         }
  170.         if (fa->fa_kaggr != objof(&o_null))
  171.         {
  172.         if ((i = new_int((long)fa->fa_index)) == NULL)
  173.             return 1;
  174.         if (assign(fa->fa_kaggr, fa->fa_kkey, i))
  175.             return 1;
  176.         loose(i);
  177.         }
  178.     }
  179.     goto next;
  180.     }
  181.     sprintf(buf, "attempt to forall over %s", objname(n, fa->fa_aggr));
  182.     error = buf;
  183.     return 1;
  184.  
  185. next:
  186.     if ((*x_top = objof(new_pc(arrayof(fa->fa_code)))) == NULL)
  187.     return 1;
  188.     ++x_top;
  189.     return 0;
  190.  
  191. fin:
  192.     --x_top;
  193.     return 0;
  194. }
  195.  
  196. STATIC
  197. type_t    forall_type =
  198. {
  199.     mark_forall,
  200.     free_simple,
  201.     hash_unique,
  202.     cmp_unique,
  203.     copy_simple,
  204.     assign_simple,
  205.     fetch_simple,
  206.     "forall"
  207. };
  208.